perm filename MATCH[PAT,LMM]4 blob
sn#085839 filedate 1974-02-03 generic text, type T, neo UTF8
(FILECREATED "16-JAN-74 3:17:00" MATCH
changes to: MAKEMATCH,'MATCHWM,'MATCHELT1,'MATCHELT,PATPARSE1,
CANMATCHNIL,DOSUBST1,FORMEXPAND,VALUELOOKUP,PATCHARS,PATERR,PATLEN,
REPLACED,'PROGN,MATCHVARS,SIMPLELT?
previous date: "10-JAN-74 08:11:47")
(LISPXPRINT (QUOTE MATCHVARS)
T)
[RPAQQ MATCHVARS
((FNS MAKEMATCH 'MATCHTOP 'MATCHSUBPAT 'MATCHWM 'MATCHWMFUNARG
CHECKSETQ 'MATCHELT1 'MATCHELT)
(FNS PATPARSE PATPARSE1 PARSEDEFAULT PATUNPACK PATUNPACKINFIX
PATGETFNNAME PATGETEXPR PATPARSEAT MAKE!PAT MAKESUBPAT
NEGATEPAT PACKLDIFF)
(FNS SKIP$I SKIP$ANY PATLEN $? ELT? SIMPLELT? ARB? NULLPAT?
NILPAT CANMATCHNIL CANMATCHNILLIST REPLACEIN REPLACED)
(FNS EASYTORECOMPUTE TEST# NEVERNIL FULLEXPANSION GENSYML
MAKESUBST MAKESUBST3 MAKESUBST0 MAKESUBST1 DOSUBST
DOSUBST1 FORMEXPAND POSTPONEDREPLACE POSTPONEDSETQ
SUBSTVAR BOUNDVAR BINDVAR SELFQUOTEABLE FINDIN0 FINDIN1
DOWATCH UNCROP PATNARGS UNCDR CHECKEASYVAR)
(FNS 'NLEFT 'NOT 'NULL 'NOT1 'NOTLESSPLENGTH 'NTH 'OR 'PLUS
'REPLACE 'SETQ 'AND 'AND2 'CAR 'CDR 'EQ 'EQLENGTH 'EQUAL
'LAST 'F/L 'APPLY* 'HEADPLOOP 'LDIFF 'PROG 'NCONC 'FOR
'PROGN 'LISTP)
(FNS PATERR PATHELP LOOKLIST VALUELOOKUP LOOK VARCHECK TRUE)
(BLOCKS (MATCHBLOCK MAKEMATCH 'MATCHTOP 'MATCHSUBPAT 'MATCHWM
'MATCHWMFUNARG CHECKSETQ 'MATCHELT1
'MATCHELT PATPARSE PATPARSE1 PARSEDEFAULT
PATUNPACK PATUNPACKINFIX PATGETFNNAME
PATGETEXPR PATPARSEAT MAKE!PAT MAKESUBPAT
NEGATEPAT PACKLDIFF SKIP$I SKIP$ANY
PATLEN $? ELT? SIMPLELT? ARB? NULLPAT?
NILPAT CANMATCHNIL CANMATCHNILLIST
REPLACEIN REPLACED EASYTORECOMPUTE TEST#
NEVERNIL FULLEXPANSION GENSYML MAKESUBST
MAKESUBST0 MAKESUBST3 MAKESUBST1 DOSUBST
DOSUBST1 FORMEXPAND POSTPONEDREPLACE
POSTPONEDSETQ SUBSTVAR BOUNDVAR BINDVAR
SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH
UNCROP PATNARGS UNCDR CHECKEASYVAR 'NLEFT
'NOT 'NULL 'NOT1 'NOTLESSPLENGTH 'NTH 'OR
'PLUS 'REPLACE 'SETQ 'AND 'AND2 'CAR 'CDR
'EQ 'EQLENGTH 'EQUAL 'LAST 'F/L 'APPLY*
'HEADPLOOP 'LDIFF 'PROG 'NCONC 'FOR
'PROGN 'LISTP PATERR PATHELP LOOKLIST
LOOK VALUELOOKUP VARCHECK TRUE
(ENTRIES MAKEMATCH)
(GLOBALVARS PATCHARS CRLIST MAXCDDDDRS
PATNONNILFUNCTIONS
PATGENSYMVARS PATTERNITEMS
PATTERNPREFIXES
PATTERNREPLACEOPRS
PATTERNINFIXES PATTERNCHARRAY
NEVERNILFUNCTIONS)
(LOCALFREEVARS WATCHPOSTPONELST SUBLIST
INASOME CHECKINGLENGTH
WMLST LASTEFFECTCANBENIL
POSTPONEDEFFECTS
MUSTRETURN BINDINGS
GENSYMVARLIST SKIPEDLEN
ZLENFLG LOCALDECLARATION
MATCHEXPRESSION
MATCHEFFECTS CHECKLENGTH
#LIST PATVARSNILLOOKED
PATVARSNIL POSTPONEDRPLACS
LISTPCHECK DEFAULTLST
VARDEFAULT)
(SPECVARS EXPR FAULTFN VARS CLISPCHANGE)
(BLKAPPLYFNS TRUE 'MATCHWMFUNARG)))
(VARS PATCHARS PATTERNINFIXES PATTERNREPLACEOPRS PATTERNITEMS
PATTERNPREFIXES CRLIST NEVERNILFUNCTIONS
PATNONNILFUNCTIONS
[PATTERNCHARRAY (MAKEBITTABLE
(NCONC (MAPCAR PATCHARS (QUOTE CAAR))
(MAPCAR PATTERNITEMS
(QUOTE CAR]
PATGENSYMVARS)
(VARS PATTERNVARDEFAULT MAXCDDDDRS (PATTERNCHECKLENGTH T)
(PATTERNLISTPCHECK NIL)
(PATVARSMIGHTBENIL T))
(PROP CLISPCLASS NTH)
(PROP CLISPCLASSDEF NTH)
(PROP LISPFN NTH)
(ADDVARS (DECLWORDS (QUOTE (NTH]
(DEFINEQ
(MAKEMATCH
[LAMBDA (MATCHEXPRESSION PATTERN)
(PROG (#LIST BINDINGS SUBLIST (GENSYMVARLIST PATGENSYMVARS)
MATCHEFFECTS
(LOCALDECLARATION (GETLOCALDEC EXPR FAULTFN))
LISTPCHECK VARDEFAULT CHECKLENGTH PATVARSNIL
PATVARSNILLOOKED)
(SETQ CLISPCHANGE T)
(SETQ CHECKLENGTH (VALUELOOKUP (QUOTE PATTERNCHECKLENGTH)))
(SETQ LISTPCHECK (VALUELOOKUP (QUOTE PATTERNLISTPCHECK)))
(SETQ VARDEFAULT (VALUELOOKUP (QUOTE PATTERNVARDEFAULT)))
[COND
(PATTERN (SETQ MATCHEXPRESSION (LIST (QUOTE match)
MATCHEXPRESSION
(QUOTE with)
PATTERN]
(SETQ MATCHEXPRESSION
(SELECTQ (CAR MATCHEXPRESSION)
((match MATCH)
[SELECTQ (CADDR MATCHEXPRESSION)
((with WITH))
(OR (FIXSPELL (CADDR MATCHEXPRESSION)
70
(QUOTE (WITH with))
T
(CDDR MATCHEXPRESSION))
(PATERR (QUOTE NOWITH)
(CDDR MATCHEXPRESSION]
('MATCHTOP
(CADR MATCHEXPRESSION)
(PROG ((TOPPAT (CADDDR MATCHEXPRESSION)))
(PATPARSE TOPPAT))
[AND (CDDDDR MATCHEXPRESSION)
(PROG ((VARS (APPEND #LIST VARS)))
(DWIMIFY1B (CDR (CDDDDR
MATCHEXPRESSION))
MATCHEXPRESSION T NIL
NIL FAULTFN)
(RETURN (CDR (CDDDDR
MATCHEXPRESSION]
(EQ (CAR (CDDDDR MATCHEXPRESSION))
(QUOTE ->))
T))
(HELP)))
(RETURN (COND
[BINDINGS ('PROG BINDINGS
(LIST (LIST (QUOTE RETURN)
MATCHEXPRESSION]
(T MATCHEXPRESSION])
('MATCHTOP
[LAMBDA (VAR PAT CONSTRUCT SMASHFLG RETURNFLG)
(PROG (POSTPONEDRPLACS POSTPONEDEFFECTS LASTEFFECTCANBENIL
MUSTRETURN WMLST WATCHPOSTPONELST SUBLIST
SAVEDUMMY)
(* POSTPONEDEFFECTS is the list of side effects
postponed -
LASTEFFECTCANBENIL is a flag which should be set
whenever a side effect is postponed
(used for determining whether the extra T at the end
is necessary) -
BINDINGS will be list of prog bindings that need to
be done -
MUSTRETURN will be the * expression, if any)
(* CHECKINGLENGTH is the flag whether the length
should be checked (used for example in
(-- 'A & &) already done the NLEFT which implicitly
checks) -
-
INASOME is a flag that says that we are, at this
level, after a -- type pattern, so that if another
-- is encountered, just reset INASOME to the match
expression for what comes after the second --;
this is so (-- A -- B --) will generate
(MEMB 'B (MEMB 'A X)) instead of
(SOME X (F/L (Z) (Z:1='A AND 'B MEMB Z::1))) -
WMLST is a stack used by *GLITCH for remembering
when a ! (SUBPAT --) is encountered to expand it,
but remember the tail after the !SUBPAT and return
(by RPLAC'ing into the corresponding entry in
WMLIST) the expression for "WHAT MATCHED" -
SUBLIST is the list where substitutions in the final
pattern are collected)
(* WATCHPOSTPONELST is a list of those vars which,
when a POSTPONE involving them is encountered, the
corresponding entry in WATCHPOSTPONELST should be
rplac'ed)
(SETQ VAR (CHECKEASYVAR (COPY VAR)
PAT))
(SETQ MATCHEXPRESSION ('MATCHSUBPAT VAR PAT))
(SETQ SUBLIST (DREVERSE SUBLIST))
[AND CONSTRUCT SMASHFLG (SETQ CONSTRUCT
(LIST (SETQ SAVEDUMMY (CONS (QUOTE DUMMY)
(CONS VAR CONSTRUCT]
[SETQ MATCHEFFECTS (NCONC (DREVERSE POSTPONEDEFFECTS)
(DREVERSE POSTPONEDRPLACS)
(COND
(CONSTRUCT)
(MUSTRETURN (LIST MUSTRETURN))
((AND LASTEFFECTCANBENIL
(NULL POSTPONEDRPLACS))
(LIST T]
(RETURN (PROG1 [DOSUBST (COND
(RETURNFLG ('AND MATCHEXPRESSION
('PROGN
MATCHEFFECTS)))
(T (CONS MATCHEXPRESSION
MATCHEFFECTS]
(AND SAVEDUMMY
(RPLNODE2 SAVEDUMMY
('REPLACE (CADR SAVEDUMMY)
('PROGN (CDDR
SAVEDUMMY])
('MATCHSUBPAT
[LAMBDA (VAR PATELT)
(PROG ((CHECKINGLENGTH T)
INASOME)
(COND
[LISTPCHECK ('AND ('LISTP VAR)
('MATCHWM VAR PATELT (QUOTE (TRUE]
(T ('MATCHWM VAR PATELT (QUOTE (TRUE])
('MATCHWM
[LAMBDA (VAR PAT FN)
(* Creates an expression which will return non-NIL
if and only if the value of the VAR expression will
match the parsed pattern PAT, and the expression
generated by applying (CAR FN) to
(the expression giving What-Matched the first
pattern element of PAT) and
(CDR FN) -
is non-nil as well. FN can hide side effects as well
i.e. FN may say to generate a side effect to be
executed if the entire pattern succeeds)
(PROG (TEM1 TEM2 TAIL ZLENFLG (SKIPEDLEN 0))
(* ZLENFLG and SKIPEDLEN
are set from within
SKIP$I and SKIP$ANY)
(COND
[(NULL PAT)
(RETURN (OR (NOT CHECKLENGTH)
(NOT CHECKINGLENGTH)
('NULL VAR]
[(NLISTP (CAR PAT))
(* The only NLISTP patterns are &, $, --, NIL, T,
strings and numbers)
(SELECTQ
(CAR PAT)
[($ --)
(RETURN
(COND
((NULL (CDR PAT)) (* Pattern ends in $ -
What matched is the
whole thing)
(BLKAPPLY* (CAR FN)
VAR
(CDR FN)))
(INASOME
(* We are within a tail which began with -- or $;
thus, we should not return the match here but
instead, SET the variable INASOME to the match
expression here and return T -
since there is no point in checking this match
expression repeatedly)
(COND
((LISTP INASOME)
(PATHELP "INASOME mismatch")))
[DOWATCH (SETQ INASOME
(PROG (INASOME)
('MATCHWM VAR PAT FN]
T)
[(ARB? (CADR PAT))
(COND
((OR (SKIP$ANY (CDDR PAT))
(NOT (ZEROP SKIPEDLEN)))
(* ($ ARB -- }FIXED) I.e. two arb's in a row,
followed by something)
(PATERR "Two arbitrary segments in a row")))
(* Must mean the second
is LAST)
('AND ('MATCHWM (SETQ TEM1 (SUBSTVAR
('LAST VAR)))
(CDR PAT)
(QUOTE (TRUE)))
(BLKAPPLY* (CAR FN)
('LDIFF VAR TEM1)
(CDR FN]
[[AND (EQ (CAR FN)
(QUOTE TRUE))
(PROGN (SETQ TAIL (SKIP$I (CDR PAT)))
(NOT (ZEROP SKIPEDLEN]
(* Special check here, since might have
(... -- $4) or not need any 'NLEFT's)
(COND
((OR (NULL TAIL)
(NULLPAT? TAIL))
(OR (NOT CHECKINGLENGTH)
('NOTLESSPLENGTH VAR SKIPEDLEN)))
[(NUMBERP SKIPEDLEN)
('MATCHWM ('NTH VAR (ADD1 SKIPEDLEN))
(CONS (CAR PAT)
TAIL)
(QUOTE (TRUE]
(T
('MATCHWM
['CDR (SETQ TEM1
(SUBSTVAR ('NTH VAR ('PLUS
SKIPEDLEN 1]
(CONS (CAR PAT)
TAIL)
(QUOTE (TRUE]
[[NILPAT (SETQ TAIL (SKIP$ANY (CDR PAT]
(PROG (CHECKINGLENGTH)
(* If pat ends in (... -- & & &) then just match
(NLEFT var 3) against & & &;
CHECKINGLENGTH = NIL will keep a
(NULL (CDDDR x)) check away)
[SETQ TEM1
(COND
[(OR (AND (REPLACED (CDR PAT))
(SETQ TEM2 (UNCDR VAR)))
(ZEROP SKIPEDLEN))
(* Check
var::-skipedlen)
('CDR (SUBSTVAR
('NLEFT TEM2 ('PLUS
SKIPEDLEN 1)
NIL ZLENFLG]
(T (SUBSTVAR ('NLEFT VAR SKIPEDLEN
NIL ZLENFLG]
('AND (OR (NOT (CANMATCHNILLIST
(CDR PAT)))
TEM1)
('MATCHWM TEM1 (CDR PAT)
(QUOTE (TRUE)))
(BLKAPPLY* (CAR FN)
('LDIFF VAR TEM1)
(CDR FN]
([AND (EQ (CAR FN)
(QUOTE TRUE))
(EQ TAIL (CDDR PAT))
(EQ SKIPEDLEN 1)
(NULLPAT? TAIL)
(EQ (CAADR PAT)
(QUOTE SUBPAT))
(OR (EQ (CAR PAT)
(QUOTE $))
(EVERY (CDDR (CADR PAT))
(FUNCTION ARB?)))
[COND
[(NLISTP (CADR (CADR PAT)))
(NOT (FMEMB (CADR (CADR PAT))
(QUOTE (& $ --]
(T (FMEMB (CAR (CADR (CADR PAT)))
(QUOTE (= == ']
(FMEMB [CAR (SETQ TEM1
('MATCHELT
(QUOTE DUMMY)
(CADR (CADR PAT]
(QUOTE (EQ EQUAL EQP STREQUAL]
(* PAT: (-- (SUBPAT
EQTYPE? ARB?) --))
(PROG [TEM2
(VAR
(LIST
(SELECTQ
(CAR TEM1)
(EQ (LOOK (QUOTE ASSOC)
VAR))
(QUOTE SASSOC))
(CADDR TEM1)
VAR))
(PAT (CONS (QUOTE &)
(CDDR (CADR PAT]
('MATCHSUBPAT (SUBSTVAR VAR)
PAT)))
(T
(PROG ({OLD⎇ {FINALLY⎇EXPR {UNTIL⎇EXPR {ON⎇VAR
[INASOME (COND
((EQ (CAR PAT)
(QUOTE $))
(QUOTE FASTINASOME))
(T (QUOTE INASOME]
(WATCHPOSTPONELST
(CONS (SETQ TEM1 (GENSYML))
WATCHPOSTPONELST)))
(* WATCHPOSTPONELST is reset so that postponed uses
of it can be detected; needed to set {OLD⎇)
(COND
((AND (REPLACED (CDR PAT))
(SETQ {ON⎇VAR (UNCDR VAR)))
(SETQ TEM2 ('CDR TEM1)))
(T (SETQ {ON⎇VAR VAR)
(SETQ TEM2 TEM1)))
[COND
(T
[SETQ {UNTIL⎇EXPR
('MATCHWM TEM2 (CDR PAT)
(QUOTE (TRUE]
(SETQ {FINALLY⎇EXPR
('AND
(BLKAPPLY* (CAR FN)
('LDIFF VAR TEM2)
(CDR FN))
(OR
[NOT
(NULL
(FMEMB INASOME
(QUOTE (INASOME
FASTINASOME]
INASOME]
(SETQ {OLD⎇ (EQ (CAR WATCHPOSTPONELST)
(QUOTE FOUND)))
(RETURN ('FOR {OLD⎇ TEM1 {ON⎇VAR
{UNTIL⎇EXPR {FINALLY⎇EXPR
(CANMATCHNILLIST
(CDR PAT]
(RETURN ('MATCHELT1 VAR PAT FN]
((SELECTQ
(CAAR PAT)
((= == ' SUBPAT } *ANY*)
(* For now, }'s can only refer to = == ' and subpats
, i.e. elementary patterns)
(RETURN ('MATCHELT1 VAR PAT FN)))
[$< (* This matches a
segment less that a
given length)
(* (FOR {TEM1⎇ ON {VAR⎇ AS {TEM2⎇ FROM {PAT:1::2⎇ TO
1 BY -1 DO (IF (MATCHES {TEM1⎇ {PAT::1⎇) THEN
(RETURN {FINALLY,SIDES⎇))))
(RETURN
(COND
[(NILPAT (CDR PAT)) (* Pattern ends in --)
('AND ['NULL ('NTH VAR ('PLUS 1 (CDAR PAT]
(BLKAPPLY* (CAR FN)
VAR
(CDR FN]
(INASOME [DOWATCH (SETQ INASOME
(PROG (INASOME)
(RETURN ('MATCHWM
VAR PAT FN]
T)
(T
(PROG ((INASOME (QUOTE INASOME)))
(SUBPAIR
(QUOTE (TEM1 VAR CNT MTCH FINALLY))
[LIST
(SETQ TEM1 (GENSYML))
VAR
(CDAR PAT)
['NOT ('MATCHWM TEM1 (CDR PAT)
(QUOTE (TRUE]
('AND (OR (EQ INASOME (QUOTE INASOME))
INASOME)
(BLKAPPLY* (CAR FN)
('LDIFF VAR TEM1)
(CDR FN]
(QUOTE
(PROG ((TEM1 VAR)
($$CNT CNT))
$$RPTLP
(COND
((IMINUSP (SETQ $$CNT
(SUB1 $$CNT)))
(RETURN))
[MTCH (COND
((LISTP TEM1)
(SETQ TEM1
(CDR TEM1))
(GO $$RPTLP))
(T (RETURN]
(T (RETURN FINALLY]
($>
(RETURN
('MATCHWM VAR
(CONS (LIST (QUOTE !)
(QUOTE SUBPAT)
(CONS (QUOTE $=)
('PLUS 1 (CDAR PAT)))
(QUOTE --))
(CDR PAT))
FN)))
[!
(RETURN
(COND
[(NILPAT (CDR PAT))
('AND [COND
[(EQ (CADAR PAT)
(QUOTE SUBPAT))
(* This isn't really a subpat and so don't rebind
CHECKINGLENGTH etc as in 'MATCHSUBPAT)
('MATCHWM VAR (CDDAR PAT)
(QUOTE (TRUE]
(T ('MATCHELT VAR (CDAR PAT]
(BLKAPPLY* (CAR FN)
VAR
(CDR FN]
((NLISTP (CAR PAT))
(PATERR "Invalid '!'" PAT))
(T
(SELECTQ
(CADAR PAT)
[= (* !=)
('HEADPLOOP VAR (CDDAR PAT)
(SETQ TEM1 (BOUNDVAR))
(CANMATCHNILLIST (CDR PAT))
('AND (BLKAPPLY* (CAR FN)
('LDIFF VAR
TEM1)
(CDR FN))
('MATCHWM
TEM1
(CDR PAT)
(QUOTE (TRUE]
[==(COND
((NULLPAT? (CDR PAT))
(PROG ((CHECKLENGTH T))
('MATCHWM VAR
(LIST (CAR PAT))
FN)))
(T (PATERR (QUOTE !AT)
(CDAR PAT]
['(COND
[[OR (NLISTP (CDDAR PAT))
(CDR (LAST (CDDAR PAT]
(COND
((NULLPAT? (CDR PAT))
(PROG ((CHECKLENGTH T))
('MATCHWM
VAR
(LIST (CAR PAT))
FN)))
(T (PATERR (QUOTE !AT)
(CDAR PAT]
(T
('MATCHWM
VAR
(CONS
[CONS
(QUOTE !)
(CONS
(QUOTE SUBPAT)
(MAPCAR
(CDDAR PAT)
(FUNCTION (LAMBDA (X)
(CONS (QUOTE ')
X]
(CDR PAT))
FN]
[SUBPAT
(* Use the *GLITCH kludge to get the whatmatched of
the rest of the thing)
(COND
[(EQ (CAR FN)
(QUOTE TRUE))
('MATCHWM VAR (APPEND (CDDAR PAT)
(CDR PAT))
(QUOTE (TRUE]
(T
(PROG ((WMLST (CONS NIL WMLST)))
(RETURN
('AND
('MATCHWM
VAR
[APPEND
(CDDAR PAT)
(LIST
(CONS
(QUOTE *GLITCH)
(CONS
WMLST
(MAKE!PAT
(MAKESUBPAT
(CDR PAT]
(QUOTE (TRUE)))
(BLKAPPLY*
(CAR FN)
('LDIFF VAR (CAR WMLST))
(CDR FN]
(PATERR "Invalid use of ! in pattern"
(CADAR PAT]
[$=(RETURN
(COND
[(NILPAT (CDR PAT))
('AND (OR (NOT CHECKINGLENGTH)
('EQLENGTH VAR (CDAR PAT)))
(BLKAPPLY* (CAR FN)
VAR
(CDR FN]
[(AND (EQ (CAR FN)
(QUOTE TRUE))
(COND
([NULLPAT? (SETQ TAIL
(SKIP$I (CDR PAT]
[SETQ TEM2
(OR (NOT CHECKINGLENGTH)
('NOTLESSPLENGTH
VAR
('PLUS (CDAR PAT)
SKIPEDLEN]
(COND
(INASOME (DOWATCH (SETQ INASOME TEM2))
T)
(T TEM2)))
((NULL TAIL)
('EQLENGTH VAR ('PLUS (CDAR PAT)
SKIPEDLEN]
[(ZEROP (CDAR PAT))
('AND (BLKAPPLY* (CAR FN)
('LDIFF VAR VAR)
(CDR FN))
('MATCHWM VAR (CDR PAT)
(QUOTE (TRUE]
(T [SETQ TEM1 (SUBSTVAR ('NTH VAR (CDAR PAT]
('AND (OR (NOT CHECKINGLENGTH)
(NOT (CANMATCHNILLIST (CDR PAT)))
TEM1)
(BLKAPPLY* (CAR FN)
('LDIFF VAR ('CDR TEM1))
(CDR FN))
('MATCHWM ('CDR TEM1)
(CDR PAT)
(QUOTE (TRUE]
[@(COND
[[AND (CDR PAT)
(NOT (ELT? (CDDAR PAT]
(RETURN
(PROG (INASOME)
('MATCHWM
VAR
[LIST
(CDDAR PAT)
(CONS
(QUOTE @)
(CONS ('APPLY* (CADAR PAT)
('LDIFF
VAR
(QUOTE @)))
(MAKE!PAT
(MAKESUBPAT (CDR PAT]
FN]
((AND NIL (NLISTP (CADAR PAT))
(GETP (CADAR PAT)
(QUOTE NARGS))
(ELT? (CDDAR PAT)))
('AND ('APPLY* (CADAR PAT)
('CAR VAR))
('MATCHWM VAR (CONS (CDDAR PAT)
(CDR PAT))
FN]
NIL))
(T (RETURN ('MATCHWM VAR (CONS (CDDAR PAT)
(CDR PAT))
(CONS (FUNCTION 'MATCHWMFUNARG)
(CONS (CAR PAT)
FN])
('MATCHWMFUNARG
[LAMBDA (X ARGS)
('AND (SELECTQ (CAAR ARGS)
[<-(OR (CHECKSETQ X ARGS)
('SETQ (CADAR ARGS)
X
(CANMATCHNIL (CDDAR ARGS]
[←(OR (CHECKSETQ X ARGS)
(POSTPONEDSETQ (CADAR ARGS)
X
(CANMATCHNIL (CDDAR ARGS]
(-> ('REPLACE X (CADAR ARGS)))
(→ (POSTPONEDREPLACE X (CADAR ARGS)))
(@('APPLY* (CADAR ARGS)
X))
(*GLITCH (FRPLACA (CADAR ARGS)
X)
(DOWATCH X)
T)
(PATHELP "MATCH FUNARG MISMATCH" ARGS))
(SELECTQ (CADR ARGS)
(TRUE T)
('MATCHWMFUNARG ('MATCHWMFUNARG X (CDDR ARGS)))
(BLKAPPLY* (CADR ARGS)
X
(CDDR ARGS])
(CHECKSETQ
[LAMBDA (X ARGS)
(COND
((FMEMB (CADAR ARGS)
#LIST)
(MAKESUBST3 (CADAR ARGS)
X)
T)
((EQ (CADAR ARGS)
(QUOTE *))
(DOWATCH X)
(SETQ MUSTRETURN X)
T])
('MATCHELT1
[LAMBDA (VAR PAT FN)
('AND [OR (NOT CHECKINGLENGTH)
(COND
((CDR PAT)
(COND
((AND (CANMATCHNIL (CAR PAT))
(CANMATCHNILLIST (CDR PAT)))
VAR)
(T T)))
((CANMATCHNIL (CAR PAT))
('EQLENGTH VAR 1))
(T ('NULL ('CDR VAR]
('MATCHELT ('CAR VAR)
(CAR PAT))
(BLKAPPLY* (CAR FN)
('CAR VAR)
(CDR FN))
(OR (NULL (CDR PAT))
(COND
([AND (EQ INASOME (QUOTE FASTINASOME))
(FMEMB (CAAR PAT)
(QUOTE (= == ']
[SETQ INASOME (PROG (INASOME)
('MATCHWM ('CDR VAR)
(CDR PAT)
(QUOTE (TRUE]
T)
(T ('MATCHWM ('CDR VAR)
(CDR PAT)
(QUOTE (TRUE])
('MATCHELT
[LAMBDA (VAR PATELT) (* This function matches
VAR against PATELT when
PATELT is a pattern
element)
(COND
((NLISTP PATELT)
(SELECTQ PATELT
(($ -- &)
T)
('EQUAL VAR PATELT)))
(T (SELECTQ (CAR PATELT)
(==('EQ VAR (CDR PATELT)))
[*ANY*('OR (MAPCAR (CDR PATELT)
(FUNCTION (LAMBDA (X)
('MATCHELT VAR X]
[}('NOT ('MATCHELT VAR (CDR PATELT]
['('EQUAL VAR (KWOTE (CDR PATELT]
(=('EQUAL VAR (CDR PATELT)))
(SUBPAT ('MATCHSUBPAT VAR (CDR PATELT)))
($=(COND
[CHECKINGLENGTH (COND
(CHECKLENGTH
('EQLENGTH VAR (CDR PATELT)))
(T ('NOTLESSPLENGTH
VAR
(CDR PATELT]
(T T)))
(PATHELP "MATCHELT invalid pattern"])
)
(DEFINEQ
(PATPARSE
[LAMBDA (PAT)
(OR (LISTP PAT)
(PATHELP "bad input" PAT))
(PROG (DEFAULTLST)
(PATPARSE1 PAT])
(PATPARSE1
[LAMBDA (PAT PREFIX) (* DECLARATIONS:
UNDOABLE)
(PROG (TEM TEM2 TEM3 CARPAT CDRPAT NOTFOUND)
(OR PAT (RETURN))
RETRY
[AND (CDR PAT)
(NLISTP (CDR PAT))
(SETQ PAT (LIST (CAR PAT)
(QUOTE %.)
(CDR PAT]
(* Take care of (a . b) by changing it to
(a %. b))
[COND
[(LISTP (CAR PAT))
(SELECTQ
(CAAR PAT)
((*ANY* *EVERY*)
[SETQ CARPAT (CONS (CAAR PAT)
(PROG ((TOPPAT (CAR PAT)))
(PATPARSE1 (CDAR PAT]
(OR (EVERY CARPAT (QUOTE SIMPLELT?))
(PATERR "*ANY*/*EVERY* construct too compicated"
PAT))
(SETQ CDRPAT (CDR PAT)))
(QUOTE
(* This is so (-- (QUOTE A) --) means
(-- 'A --); this kludge is necessary now since
DWIMIFY1B sometimes parses the 'A into
(QUOTE A))
[COND
[(NOT (ATOM (CADAR PAT)))
(/RPLNODE PAT (QUOTE ')
(CONS (CADAR PAT)
(CDR PAT]
(T (/RPLACA PAT (PACK (LIST (QUOTE ')
(CADAR PAT]
(GO RETRY))
[LAMBDA
(* (-- (LAMBDA (X) --) --) means
(-- &@ (LAMBDA (X) --)))
(/ATTACH (QUOTE &@)
PAT)
(GO RETRY]
(PROGN (* Otherwise, it's a
sub-pattern)
[SETQ CARPAT (MAKESUBPAT
(PROG ((TOPPAT (CAR PAT)))
(PATPARSE1 (CAR PAT]
(SETQ CDRPAT (CDR PAT]
((NOT (LITATOM (CAR PAT))) (* Strings and numbers
parse to themselves)
(OR (STRINGP (CAR PAT))
(NUMBERP (CAR PAT))
(PATERR (QUOTE BADELT)
(CAR PAT)))
(SETQ CARPAT (CAR PAT))
(SETQ CDRPAT (CDR PAT)))
((SETQ TEM (FASSOC (CAR PAT)
PATTERNITEMS))
(* If this is a pattern item;
PATTERNITEMS is an association list;
with an entry being (iteminpattern parsing
smashpatwith))
(SETQ CARPAT (OR (CADR TEM)
(CAR TEM)))
(SETQ CDRPAT (CDR PAT)))
((SETQ TEM (FASSOC (CAR PAT)
PATTERNPREFIXES))
(* PATTERNPREFIXES is an association list of
(opr type form); opr is the 'OPERATOR'
(e.g. =); type is either PAT, T, or expr;
PAT means the next thing is a pattern
(as in !) and expr means the next thing is a lisp
expression (e.g. =))
(SETQ TEM3 T)
(SETQ TEM2 (SELECTQ (CADR TEM)
(EXPR (PATGETEXPR (CDR PAT)))
[PAT (CAR (SETQ TEM3
(PATPARSE1 (CDR PAT]
(CADR PAT)))
[SETQ CARPAT
(COND
((LISTP (CADDR TEM))
(SUBST TEM2 (QUOTE HERE)
(CADDR TEM)))
(T (SELECTQ (CADDR TEM)
(NEGATEPAT (NEGATEPAT TEM2 PAT))
(MAKE!PAT (MAKE!PAT TEM2 TEM3 PAT PREFIX))
(BLKAPPLY* (CADDR TEM)
TEM2 TEM3 PAT PREFIX]
[COND
((NEQ TEM3 T)
(RETURN (CONS CARPAT (CDR TEM3]
(SETQ CDRPAT (CDDR PAT)))
((SETQ TEM (PATUNPACK PAT))
(SETQ PAT TEM)
(* Now, either we have a "DEFAULT" condition, or
else a var infix condition)
(GO RETRY))
(T (SETQ NOTFOUND PAT)
(SETQ CARPAT (CAR PAT))
(SETQ CDRPAT (CDR PAT]
(* By now, CARPAT is set to the parsing of the first
thing in PAT; and CDRPAT is the appropriate tail;
want to check for infix operators;
if NOTFOUND is non-nil, then CARPAT was an atom
which wasn't parseable as a pattern;
might be a variable if followed by a ←)
REINFIX
(COND
((SETQ TEM (FASSOC (CAR CDRPAT)
PATTERNREPLACEOPRS))
[COND
[NOTFOUND
(* CARPAT is not a pattern, and followed by a ←;
want to know if the next thing is a pattern or
something else; it is assumed that var←pattern is
meant; I could change it to mean pat←var)
(TEST# CARPAT)
(SETQ TEM3 (PATPARSE1 (CDR CDRPAT)
CDRPAT))
(RETURN (CONS (CONS (CADR TEM)
(CONS CARPAT
(CAR TEM3)))
(CDR TEM3]
(T (SETQ CARPAT (CONS (CADDR TEM)
(CONS (PATGETEXPR (CDR CDRPAT))
CARPAT)))
(SETQ CDRPAT (CDDR CDRPAT]
(GO REINFIX))
(NOTFOUND (COND
(PREFIX (PATERR (QUOTE AMBIG)
PAT)))
(SETQ PAT (PARSEDEFAULT PAT NIL PREFIX))
(SETQ NOTFOUND)
(GO RETRY))
((EQ (CAR CDRPAT)
(QUOTE @))
(SETQ CARPAT (CONS (QUOTE @)
(CONS (PATGETFNNAME (CDR CDRPAT))
CARPAT)))
(SETQ CDRPAT (CDDR CDRPAT))
(GO REINFIX))
((SETQ TEM (PATUNPACKINFIX CDRPAT))
(SETQ CDRPAT TEM)
(GO REINFIX)))
(RETURN (CONS CARPAT (PATPARSE1 CDRPAT])
(PARSEDEFAULT
[LAMBDA (PAT LOCALVARDEFAULT PREFIX)
(* Turns PAT:1 (which is a LITATOM) into the "DEFAULT"
pattern -
I.e. PAT:1 couldn't be parsed as a pattern -
It is assumed that the default for an atom is an
element pattern)
(OR (AND (LITATOM (CAR PAT))
(NEQ (CAR PAT)
T)
(CAR PAT))
(PATHELP "MAKEDEFAULT" (CAR PAT)))
(PROG (SMASHFLG NEWPAT)
(COND
((FMEMB (CAR PAT)
DEFAULTLST) (* Second occurance of a
"DEFAULT" is defaulted
to =)
(SETQQ LOCALVARDEFAULT =))
([COND
((STRPOS "#" (CAR PAT)
1 NIL 1)
(OR [NUMBERP (PACK (CDR (DUNPACK (CAR PAT)
SKORLST3]
(PATERR (QUOTE BAD#)
PAT)))
((STRPOS "*" (CAR PAT))
(OR (EQ (CAR PAT)
(QUOTE *))
(PATERR (QUOTE BAD*)
PAT] (* #n is defaulted to ←
the first time)
(SETQQ LOCALVARDEFAULT SETQ)))
RETRY
[SETQ NEWPAT
(SELECTQ
(OR LOCALVARDEFAULT (AND (NLISTP VARDEFAULT)
VARDEFAULT))
[(← SETQ SET)
(SETQ DEFAULTLST (CONS (CAR PAT)
DEFAULTLST))
(CONS (CAR PAT)
(CONS (QUOTE ←)
(CONS (QUOTE &)
(CDR PAT]
[(QUOTE ')
(COND
(SMASHFLG (/ATTACH (QUOTE ')
PAT))
(T (RETURN (CONS (QUOTE ')
PAT]
[(= EQUAL)
(COND
(SMASHFLG (/ATTACH (QUOTE =)
PAT))
(T (RETURN (CONS (QUOTE =)
PAT]
[(== EQ)
(COND
(SMASHFLG (/ATTACH (QUOTE ==)
PAT))
(T (RETURN (CONS (QUOTE ==)
PAT]
[(@ APPLY*)
(COND
(SMASHFLG (/ATTACH (QUOTE $1@)
PAT))
(T (RETURN (CONS (QUOTE $1)
(CONS (QUOTE @)
PAT]
(PROGN
(SETQ SMASHFLG T)
[SETQ LOCALVARDEFAULT
(COND
(LOCALVARDEFAULT
(PATERR (COND
(VARDEFAULT "invalid PATTERNVARDEFAULT")
(T (QUOTE AMBIG)))
PAT))
((EQ 1 (GETP (CAR PAT)
(QUOTE NARGS)))
(SETQ SMASHFLG)
(QUOTE @))
((VARCHECK (CAR PAT)
T T T)
(QUOTE =))
((LISTP VARDEFAULT)
(CAR VARDEFAULT))
(T (QUOTE ?]
(GO RETRY]
(COND
(SMASHFLG (/RPLNODE2 PAT NEWPAT)
(RETURN PAT))
(T (RETURN NEWPAT])
(PATUNPACK
[LAMBDA (PAT)
(* THIS WOULD BE SIMPLER IF THERE WERNT THINGS LIKE
$N AROUND -- THIS FUNCTION UNPACKS
(CAR PAT) ALONG THE LINES OF PATTERN OPERATORS -
I'LL MAKE IT SIMPLER BY ASSUMING THAT THINGS ARE OK
(I.E. WILL UNPACK) (AND (STRPOSL PATTERNCHARRAY
(CAR PAT)) (PROG ((CHARS (DUNPACK
(CAR PAT) SKORLST2)) RESULTS) RETRY
(for CHR on CHARS do (for X in PATCHRLST bind TAIL
do (SETQ TAIL CHR) (COND ((for Z in
(CDR X) always (COND ((EQ Z
(CAR TAIL)) (SETQ TAIL (CDR TAIL)) T)))
(* CHARS IS (... PATCHRSTRING ...); WE TAKE AND PUT
ON RESULTS THE UNPACKING OF THE FIRST AND REST)
(SETQ RESULTS (NCONC RESULTS
(COND ((NEQ CHR CHARS) (LIST
(PACK (LDIFF CHARS CHR))))
(T NIL)) (LIST (CAR X)))) (SETQ CHARS TAIL)
(GO RETRY))))) (AND RESULTS
(NCONC1 RESULTS (PACK CHARS))
(RETURN RESULTS)))))
(PATPARSEAT PAT PATCHARS])
(PATUNPACKINFIX
[LAMBDA (L)
(PATPARSEAT L PATTERNINFIXES])
(PATGETFNNAME
[LAMBDA (L)
(OR (LISTP (CAR L))
(FGETD (CAR L))
(FIXSPELL (CAR L)
70 SPELLINGS2 T L (FUNCTION GETD)
T)
(FIXSPELL (CAR L)
70 USERWORDS T L (FUNCTION GETD)
T))
(CAR L])
(PATGETEXPR
[LAMBDA (L)
(PATUNPACK L)
(* THIS DOESN'T WORK, BUT I'LL KEEP THE IDEA HERE IN
THIS COMMENT (PROG ((VARS (APPEND #LIST VARS)))
(DWIMIFY1B L TOPPAT L T T FAULTFN)
(while (AND (NOT (PARSEABLE
(CDR L))) (DWIMIFY1B (CDR L) TOPPAT L T T FAULTFN))
do NIL) (RETURN (CAR L))) -
WHERE PARSEABLE IS DEFINED AS
(LAMBDA (PATTERN) (OR (NLISTP PATTERN)
(NOT (LITATOM (CAR PATTERN)))
(NULL (CAR PATTERN)) (EQ (CAR PATTERN) T)
(FASSOC (CAR PATTERN) PATTERNITEMS)
(FASSOC (CAR PATTERN) PATTERNINFIXES)
(FASSOC (CAR PATTERN) PATTERNPREFIXES)
(AND (PATUNPACK PATTERN) (PARSEABLE PATTERN)))))
(COND
((LISTP (CAR L))
(DWIMIFY1B (CAR L)
(CAR L)
NIL NIL NIL FAULTFN)))
(CAR L])
(PATPARSEAT
[LAMBDA (PAT CHRS)
(* Breaks apart (CAR PAT) if possible, replaces the
parsing into the beginning of PAT ;
otherwise return NIL if can't -
CHRS is a list of args as if to STRPOS, i.e. check
(STRPOS X:1 PAT:1 1 NIL X:2) for X in CHRS -
X:1 is the char list, X:2 is ANCHOR)
(PROG (TEM DONEANYTHING LST POS)
(OR (STRPOSL PATTERNCHARRAY (CAR PAT))
(RETURN))
(SETQ LST (DUNPACK (CAR PAT)
SKORLST3))
LP (COND
((NULL CHRS)
(RETURN))
((EQ (CADDR (CAR CHRS))
(CAR PAT))
(RETURN))
([NOT (SETQ POS (COND
[(NULL (CADAR CHRS))
(find X on LST suchthat (for Z
in (CAAR CHRS)
as ZZ
in X
always (EQ Z ZZ]
((for Z in (CAAR CHRS) as ZZ in LST
always (EQ Z ZZ))
LST]
(SETQ CHRS (CDR CHRS))
(GO LP)))
(* Found one -
POS is now the tail of LST which begins with one of
the operators)
[SETQ PAT (CONS (CAR PAT)
(COND
([SETQ TEM
(FNTH POS (ADD1 (FLENGTH (CAAR CHRS]
(CONS (PACK TEM)
(CDR PAT)))
(T (CDR PAT]
[SETQ TEM
(COND
([AND TEM (EQ (CADDR (CAR CHRS))
(QUOTE $))
(NOT (FMEMB (CAR TEM)
(QUOTE (← @ = < >]
(QUOTE $=))
(T (CADDR (CAR CHRS]
(COND
[(NEQ POS LST)
(RPLNODE PAT (PACKLDIFF LST POS)
(CONS TEM (CDR PAT]
(T (FRPLACA PAT TEM)))
(RETURN PAT])
(MAKE!PAT
[LAMBDA (PATELT PATALL REALPAT PREFIX)
(COND
((AND (EQ (CAR REALPAT)
(QUOTE !))
(EQ PATELT (CAR PATALL))
(OR (EQ (CAR PATELT)
(QUOTE ←))
(EQ (CAR PATELT)
(QUOTE <-)))
(NOT (FMEMB (CADR PATELT)
DEFAULTLST)))
(* Change PATALL to ((← var ! subpat %.
all of it)) from ((← var . part1) part2))
[FRPLACD (CDR PATELT)
(MAKE!PAT (MAKESUBPAT (CONS (CDDR PATELT)
(CDR PATALL]
(FRPLACD PATALL NIL)
PATELT)
(T
(OR (COND
((NLISTP PATELT)
(SELECTQ PATELT
(& (QUOTE $))
(($ --)
(QUOTE $))
NIL))
(T (SELECTQ (CAR PATELT)
(! (PATERR (QUOTE TWO!)
PATELT))
((← <- → -> @)
(FRPLACD (CDR PATELT)
(MAKE!PAT (CDDR PATELT)))
PATELT)
[* (CONS (CAR PATELT)
(MAKE!PAT (CDR PATELT]
(SUBPAT (AND (NULL (CDDR PATELT))
(NOT (ELT? (CADR PATELT)))
(CADR PATELT)))
($= PATELT)
NIL)))
(CONS (QUOTE !)
PATELT])
(MAKESUBPAT
[LAMBDA (PATLST)
(COND
((NULL PATLST)
NIL)
([OR (EQUAL PATLST (QUOTE (--)))
(EQUAL PATLST (QUOTE ($]
(QUOTE &))
(T (CONS (QUOTE SUBPAT)
PATLST])
(NEGATEPAT
[LAMBDA (PE REALPAT)
(OR (NLISTP PE)
(FMEMB (CAR PE)
(QUOTE (= == ' SUBPAT)))
(PATERR (QUOTE BADNOT)
REALPAT))
(CONS (QUOTE })
PE])
(PACKLDIFF
[LAMBDA (LST1 LST2)
(PROG (TEM1 TEM2)
(FRPLACD (OR (SETQ TEM1 (NLEFT LST1 1 LST2))
(HELP))
NIL)
(PROG1 (PACK LST1)
(FRPLACD TEM1 TEM2])
)
(DEFINEQ
(SKIP$I
[LAMBDA (PAT)
(* Returns to the first TAIL of PAT which doesn't
begin with a $i or a $$foo -
Sets the variable "LEN" to the total length of
things skipped over)
(SOME PAT (FUNCTION (LAMBDA (ELT)
(COND
((EQ ELT (QUOTE &))
(SETQ SKIPEDLEN ('PLUS 1 SKIPEDLEN))
NIL)
((EQ (CAR ELT)
(QUOTE $=))
(SETQ SKIPEDLEN ('PLUS SKIPEDLEN (CDR ELT)))
NIL)
(T])
(SKIP$ANY
[LAMBDA (PAT)
(* Scans PAT until a pattern element which matches
an arbitrary length segment is hit -
Adds the length skipped to the variable SKIPEDLEN;
and sets ZLENFLG if finds any of zero length)
(SOME PAT (FUNCTION (LAMBDA (ELT TEM)
(COND
((NULL (SETQ TEM (PATLEN ELT)))
T)
((ZEROP TEM)
(SETQ ZLENFLG T)
NIL)
(T (SETQ SKIPEDLEN ('PLUS SKIPEDLEN TEM))
NIL])
(PATLEN
[LAMBDA (PATELT !ED)
(PROG NIL
LP (RETURN
(COND
[(NLISTP PATELT)
(SELECTQ PATELT
(($ --)
NIL)
(& (AND (NOT !ED)
1))
(COND
(!ED 0)
(T 1]
(T
(SELECTQ
(CAR PATELT)
(SUBPAT (COND
[!ED (for PE1 in (CDR PATELT) bind PLEN←0
finally (RETURN PLEN)
do (SETQ PLEN
('PLUS PLEN
(OR (PATLEN PE1)
(RETURN NIL]
(T 1)))
($=(CDR PATELT))
((← -> <- → @ *GLITCH)
(SETQ PATELT (CDDR PATELT))
(GO LP))
(! (SETQ PATELT (CDR PATELT))
(SETQ !ED T)
(GO LP))
('(COND
(!ED (LENGTH (CDR PATELT)))
(T 1)))
((= == }) (* Currently, } can only
refer to subpatterns, =,
==, and ')
(AND (NOT !ED)
1))
(($> $<)
NIL)
(PATHELP "PATLEN invalid pattern" PATELT])
($?
[LAMBDA (PATELT)
(OR (EQ PATELT (QUOTE --))
(EQ PATELT (QUOTE $])
(ELT?
[LAMBDA (PATELT)
(COND
[(NLISTP PATELT)
(OR (NUMBERP PATELT)
(STRINGP PATELT)
(FMEMB PATELT (QUOTE (& NIL T]
(T (SELECTQ (CAR PATELT)
((= == ' SUBPAT }) (* Currently, } can only
refer to =, ==, ', and
subpatterns)
T)
((← -> <- → @ *GLITCH)
(ELT? (CDDR PATELT)))
NIL])
(SIMPLELT?
[LAMBDA (PATELT)
(OR (NLISTP PATELT)
(SELECTQ (CAR PATELT)
(@(SIMPLELT? (CDDR PATELT)))
((← -> <- →)
NIL)
T])
(ARB?
[LAMBDA (PATELT)
(COND
((NLISTP PATELT)
($? PATELT))
(T (SELECTQ (CAR PATELT)
(! NIL)
((<- → ← -> *GLITCH)
(ARB? (CDDR PATELT)))
NIL])
(NULLPAT?
[LAMBDA (PAT)
(COND
((NULL PAT)
(NOT CHECKLENGTH))
(T (EVERY PAT (FUNCTION $?])
(NILPAT
[LAMBDA (PATLIST)
(AND CHECKLENGTH (NULL PATLIST])
(CANMATCHNIL
[LAMBDA (PATELT)
(* Returns T if PATELT matches NIL, NIL if it
doesn't, and something ELSE
(maybe) if it might (e.g., =FOO))
(COND
((NLISTP PATELT)
(AND (FMEMB PATELT (QUOTE (& NIL $ --)))
T))
((NLISTP (CAR PATELT))
(SELECTQ (CAR PATELT)
[@(AND (CANMATCHNIL (CDDR PATELT))
(NOT (FMEMB (CADR PATELT)
PATNONNILFUNCTIONS))
(QUOTE (MAYBE, MAYBE NOT]
(SUBPAT (CANMATCHNILLIST (CDR PATELT)))
($< T)
($=(OR (NOT (NUMBERP (CDR PATELT)))
(ILESSP (CDR PATELT)
1)))
($> NIL)
((← -> → <- *GLITCH)
(CANMATCHNIL (CDDR PATELT)))
(! (CANMATCHNIL (CDR PATELT)))
('(NULL (CDR PATELT)))
[(= ==)
(NOT (NEVERNIL (CDR PATELT]
(*ANY*(SOME (CDR PATELT)
(FUNCTION CANMATCHNIL)))
(}(CDR PATELT))
(PATHELP "CANMATCHNIL invalid pattern" PATELT)))
(T (PATHELP "CANMATCHNIL invalid pattern"])
(CANMATCHNILLIST
[LAMBDA (PATLIST)
(EVERY PATLIST (FUNCTION (LAMBDA (PE)
(AND (OR (NOT CHECKINGLENGTH)
(NOT (ELT? PE)))
(CANMATCHNIL PE])
(REPLACEIN
[LAMBDA (PATELT)
(AND (LISTP PATELT)
(SELECTQ (CAR PATELT)
((-> → *GLITCH)
(* the *GLITCH might or might not be a replace, but
can't take any chances)
T)
((@ ← <-)
(REPLACEIN (CDDR PATELT)))
(! (REPLACEIN (CDR PATELT)))
(SUBPAT (SOME (CDR PATELT)
(FUNCTION REPLACEIN)))
(($= = == ' $< $> }) (* All of these cannot
be pointing at a
REPLACE)
NIL)
(PATHELP "Invalid pattern REPLACEIN" PATELT])
(REPLACED
[LAMBDA (PAT)
(for X in PAT do (COND
((ELT? X)
(RETURN))
((REPLACEIN X)
(RETURN T])
)
(DEFINEQ
(EASYTORECOMPUTE
[LAMBDA (EXPRESSION)
(* If the EXPRESSION is some cadddaars of a
variable, return that variable
(something needs to check for VARS bound IN somes
and internal forms for WHEN it can't use it for the
*'s value))
(OR (AND (NLISTP EXPRESSION)
EXPRESSION)
(AND [OR (GETP (CAR EXPRESSION)
(QUOTE CROPS))
(FMEMB (CAR EXPRESSION)
(QUOTE (CAR CDR]
(EASYTORECOMPUTE (CADR EXPRESSION])
(TEST#
[LAMBDA (VAR) (* Check if VAR is a #n
type variable)
(COND
((FMEMB VAR #LIST))
((STRPOS "#" VAR 1 NIL 1)
(SETQ #LIST (CONS VAR #LIST])
(NEVERNIL
[LAMBDA (X)
(COND
[(LITATOM X)
(OR (EQ X T)
(AND X (NOT (COND
(PATVARSNILLOOKED PATVARSNIL)
(T (SETQ PATVARSNIL (VALUELOOKUP
(QUOTE PATVARSMIGHTBENIL]
(T (OR (NLISTP X)
(FMEMB (GETP (CAR X)
(QUOTE CLISPCLASS))
(QUOTE (+ * ↑ RPLACA RPLACD / - +-)))
(FMEMB (CAR X)
NEVERNILFUNCTIONS])
(FULLEXPANSION
[LAMBDA (X)
(PROG (TEM)
(COND
([OR (EQ (CAR X)
(QUOTE CAR))
(EQ (CAR X)
(QUOTE CDR))
(NULL (SETQ TEM (FASSOC (CAR X)
CRLIST]
X)
(T (LIST (CADDDR TEM)
(LIST (CAR (CDDDDR TEM))
(CADR X])
(GENSYML
[LAMBDA NIL
(OR (CAR (SETQ GENSYMVARLIST (CDR GENSYMVARLIST)))
(GENSYM])
(MAKESUBST
[LAMBDA (OLD NEW NOVARFLG)
(SETQ SUBLIST (CONS [CONS OLD (CONS NEW (NOT (NULL NOVARFLG]
SUBLIST))
OLD])
(MAKESUBST3
[LAMBDA (VAR VAL)
(DOWATCH VAR)
(DOWATCH VAL)
(MAKESUBST0 VAR VAL])
(MAKESUBST0
[LAMBDA (OLD NEW)
(MAKESUBST OLD NEW NIL])
(MAKESUBST1
[LAMBDA (OLD NEW)
(MAKESUBST OLD NEW (EASYTORECOMPUTE NEW])
(DOSUBST
[LAMBDA (EXPRESSION)
(* This function does the post substitution in the
EXPRESSION; it uses SUBLIST to substitute;
an entry in SUBLIST is (VAR NEWVALUE . FOUND) where
FOUND is initially NIL; when the VAR is found for
the first time, the FOUND field is smashed with a
pointer to that place of substitution;
then if it is found again, the old place is smashed
with a (SETQ $$I VALUE) and then the newvalue is
made $$I, and "FOUND" is changed to T -
thus, if an expression occurs once, it is
substituted directly; more than once and
(SETQ $$I -
) is put in the first place and $$I in the rest)
(OR (COND
[(NLISTP EXPRESSION)
(CAR (DOSUBST1 (LIST EXPRESSION]
(T (DOSUBST1 EXPRESSION)))
EXPRESSION])
(DOSUBST1
[LAMBDA (EXPRESSION PARENTEXPRESSION)
(PROG (TEM1 TEM2)
(COND
((NLISTP EXPRESSION)
NIL)
([SETQ TEM1 (find X in SUBLIST
suchthat (COND
[(NLISTP X)
(COND
((EQ X (CAR EXPRESSION))
(RETURN]
(T (EQ (CAR X)
(CAR EXPRESSION]
(* (CAR EXPRESSION)
needs to be substituted
for)
(SETQ EXPRESSION (CONS (CAR EXPRESSION)
(CDR EXPRESSION)))
(COND
((LISTP (CDDR TEM1)) (* We have already
substituted for it)
(SETQ TEM2 (BOUNDVAR))
(FRPLACA (CDDR TEM1)
('SETQ TEM2 (CADDR TEM1)))
(FRPLACA (CDR TEM1)
TEM2)
(FRPLACD (CDR TEM1)
T) (* Mark it that it's
been found twice)
)
((NULL (CDDR TEM1)) (* Haven't seen it
before)
(FRPLACD (CDR TEM1)
EXPRESSION)))
(FRPLACA EXPRESSION (OR (DOSUBST1 (CADR TEM1))
(CADR TEM1)))
(* Might need to
substitutions within
substituted EXPRESSION)
(FRPLACD EXPRESSION (OR (DOSUBST1 (CDR EXPRESSION))
(CDR EXPRESSION)))
EXPRESSION)
(T
(SELECTQ
(CAR EXPRESSION)
[(PROG LAMBDA)
(* Don't want to substitute for lambda variables
within the lambda; this is so that the same variable
can be used for a some tail within the some and
outside of it)
(PROG ((SUBLIST (NCONC [MAPCAR
(CADR EXPRESSION)
(FUNCTION (LAMBDA (X)
(COND
((LISTP X)
(CAR X))
(T X]
SUBLIST))
TEM)
(COND
((SETQ TEM (DOSUBST1 (CDDR EXPRESSION)))
(FRPLACD (CDR EXPRESSION)
TEM)
EXPRESSION]
(QUOTE NIL)
(PROG (A D)
(SETQ A (DOSUBST1 (CAR EXPRESSION)))
(SETQ D (DOSUBST1 (CDR EXPRESSION)))
(COND
((EQ (CAR EXPRESSION)
(QUOTE DUMMY))
(AND D (FRPLACD EXPRESSION D))
(RETURN)))
(AND (OR A D)
(CONS (OR A (CAR EXPRESSION))
(OR D (CDR EXPRESSION])
(FORMEXPAND
[LAMBDA (LIST AT)
(* Searches for (AT --) AT the top level of list and
does a (1) up (bo 1) on them)
[for X on LIST do (AND (EQ (CAAR X)
AT)
(FRPLACD X (NCONC (CDDAR X)
(CDR X)))
(FRPLACA X (CADAR X]
LIST])
(POSTPONEDREPLACE
[LAMBDA (VAR VALUE)
(DOWATCH VALUE)
(DOWATCH VAR)
(SETQ POSTPONEDRPLACS (CONS ('REPLACE VAR VALUE)
POSTPONEDRPLACS))
T])
(POSTPONEDSETQ
[LAMBDA (VARTOSET VALUE CANBENILFLG)
(DOWATCH VARTOSET)
(DOWATCH VALUE)
(SETQ POSTPONEDEFFECTS (CONS ('SETQ VARTOSET VALUE)
POSTPONEDEFFECTS))
(SETQ LASTEFFECTCANBENIL CANBENILFLG)
T])
(SUBSTVAR
[LAMBDA (EXPR)
(PROG (TEM)
(MAKESUBST0 (SETQ TEM (GENSYML))
EXPR)
(RETURN TEM])
(BOUNDVAR
[LAMBDA NIL
(BINDVAR (GENSYML])
(BINDVAR
[LAMBDA (VAR)
(SETQ BINDINGS (CONS VAR BINDINGS))
VAR])
(SELFQUOTEABLE
[LAMBDA (EXPRESSION)
(OR (NUMBERP EXPRESSION)
(STRINGP EXPRESSION)
(NULL EXPRESSION)
(EQ EXPRESSION T])
(FINDIN0
[LAMBDA (VAR EXPR)
(OR (FINDIN1 VAR EXPR)
(SOME SUBLIST (FUNCTION (LAMBDA (X)
(AND (FINDIN1 (CAR X)
EXPR)
(FINDIN1 VAR (CDR X])
(FINDIN1
[LAMBDA (AT LST) (* CHEAP EDITFINDP)
(OR (EQ AT LST)
(AND (LISTP LST)
(OR (FINDIN1 AT (CAR LST))
(FINDIN1 AT (CDR LST])
(DOWATCH
[LAMBDA (EXPR)
(AND WATCHPOSTPONELST (MAP WATCHPOSTPONELST
(FUNCTION (LAMBDA (X)
(AND (NEQ (CAR X)
(QUOTE FOUND))
(FINDIN0 (CAR X)
EXPR)
(FRPLACA X (QUOTE FOUND])
(UNCROP
[LAMBDA (EXPR)
(COND
((NLISTP EXPR)
EXPR)
((GETP (CAR EXPR)
(QUOTE CROPS))
(UNCROP (CADR EXPR)))
(T (SELECTQ (CAR EXPR)
((CAR CDR NTH NLEFT LAST FLAST FNTH SOME)
(UNCROP (CADR EXPR)))
((MEMB FMEMB MEMBER)
(UNCROP (CADDR EXPR)))
EXPR])
(PATNARGS
[LAMBDA (X)
(OR (GETP X (QUOTE NARGS))
(NARGS X])
(UNCDR
[LAMBDA (VAR)
(AND (EQ (CAR (SETQ VAR (FULLEXPANSION VAR)))
(QUOTE CDR))
(CADR VAR])
(CHECKEASYVAR
[LAMBDA (VAR PAT)
(PROG (TEM)
(COND
((EASYTORECOMPUTE VAR)
VAR)
(T (COND
[[AND (REPLACED PAT)
(FMEMB (CAR (SETQ TEM (FULLEXPANSION VAR)))
(QUOTE (CAR CDR]
(LIST (CAR TEM)
(SUBSTVAR (CADR TEM]
(T (SUBSTVAR VAR])
)
(DEFINEQ
('NLEFT
[LAMBDA (EXPRESSION N TAIL NOTFASTFLG)
(COND
(TAIL (LIST (QUOTE NLEFT)
EXPRESSION N TAIL))
((ZEROP N) (* NO LOOKUP DONE SINCE
FLAST DOESN'T MAKE SENSE
HERE)
(LIST (QUOTE CDR)
(LIST (QUOTE LAST)
EXPRESSION)))
[(EQ N 1)
(COND
(NOTFASTFLG (LIST (QUOTE LAST)
EXPRESSION))
(T ('LAST EXPRESSION]
(T (LIST (QUOTE NLEFT)
EXPRESSION N])
('NOT
[LAMBDA (X)
('NOT1 X (QUOTE NOT])
('NULL
[LAMBDA (X)
('NOT1 X (QUOTE NULL])
('NOT1
[LAMBDA (X FNNAME)
(COND
((NLISTP X)
(SELECTQ X
(NIL T)
(T NIL)
(LIST FNNAME X)))
(T (SELECTQ (CAR X)
((NOT NULL)
(CADR X))
(EQ (FRPLACA X (QUOTE NEQ)))
(NEQ (FRPLACA X (QUOTE EQ)))
[(OR AND)
(for Y on (CDR X)
do (FRPLACA Y ('NOT1 (CAR Y)
FNNAME)))
(FRPLACA X (COND
((EQ (CAR X)
(QUOTE AND))
(QUOTE OR))
(T (QUOTE OR]
(LISTP (FRPLACA X (QUOTE NLISTP)))
(NLISTP (FRPLACA X (QUOTE LISTP)))
(LIST FNNAME X])
('NOTLESSPLENGTH
[LAMBDA (X N)
(COND
((ZEROP N)
T)
(T ('NTH X N])
('NTH
[LAMBDA (VAR LEN)
(COND
((OR (NOT (SMALLP LEN))
(ILESSP LEN 1)
(IGREATERP LEN MAXCDDDDRS))
(LIST (COND
(CHECKINGLENGTH (LOOK (QUOTE NTH)))
(T (QUOTE FNTH)))
VAR LEN))
(T (PROG NIL
LP (COND
((EQ LEN 1)
VAR)
((EQ LEN 2)
(LIST (QUOTE CDR)
VAR))
((EQ LEN 3)
(LIST (QUOTE CDDR)
VAR))
((EQ LEN 4)
(LIST (QUOTE CDDDR)
VAR))
((EQ LEN 5)
(LIST (QUOTE CDDDDR)
VAR))
(T (WHILE (IGREATERP LEN 5)
DO (SETQ VAR (LIST (QUOTE CDDDDR)
VAR))
(SETQ LEN (IDIFFERENCE LEN 4)))
(GO LP])
('OR
[LAMBDA (LISTOFEXPRESSIONS)
(COND
[(CDR LISTOFEXPRESSIONS)
(CONS (QUOTE OR)
(FORMEXPAND LISTOFEXPRESSIONS (QUOTE OR]
(T (CAR LISTOFEXPRESSIONS])
('PLUS
[LAMBDA (EXPR1 EXPR2)
(COND
((AND (NUMBERP EXPR1)
(NUMBERP EXPR2))
(IPLUS EXPR1 EXPR2))
(T (PROG ((SUM 0)
(LST (FORMEXPAND (LIST EXPR1 EXPR2)
(QUOTE IPLUS)))
VAL)
[FOR X in LST do (COND
((NUMBERP X)
(SETQ SUM (IPLUS X SUM)))
(T (SETQ VAL (NCONC1 VAL X]
(COND
((NULL VAL) SUM)
((IGREATERP SUM 0)
(CONS (QUOTE IPLUS)
(CONS SUM VAL)))
((NULL (CDR VAL))
(CAR VAL))
(T (CONS (QUOTE IPLUS)
VAL])
('REPLACE
[LAMBDA (VAR EXPRESSION)
(SETQ VAR (FULLEXPANSION VAR))
(COND
((EQUAL VAR EXPRESSION)
T)
((EQ (CAR VAR)
(QUOTE CAR))
(LOOKLIST (QUOTE RPLACA)
(CADR VAR)
EXPRESSION))
((EQ (CAR VAR)
(QUOTE CDR))
(LOOKLIST (QUOTE RPLACD)
(CADR VAR)
EXPRESSION))
[(EQ (CAR VAR)
(QUOTE LDIFF))
('REPLACE (CADR VAR)
('NCONC EXPRESSION (CADDR VAR]
[(COND
((EQ (CAR EXPRESSION)
(QUOTE CONS))
T)
((EQ (CAR EXPRESSION)
(QUOTE LIST))
[COND
((CDDR EXPRESSION)
(SETQ EXPRESSION (LIST NIL (CADR EXPRESSION)
(CONS (QUOTE LIST)
(CDDR EXPRESSION]
T))
('PROGN (LIST ('REPLACE (LIST (QUOTE CAR)
VAR)
(CADR EXPRESSION))
('REPLACE (LIST (QUOTE CDR)
VAR)
(CADDR EXPRESSION]
(T (LOOKLIST (QUOTE RPLNODE2)
VAR EXPRESSION])
('SETQ
[LAMBDA (VAR EXPRESSION PROGNFLG)
(SETQ EXPRESSION (LIST (QUOTE SETQ)
VAR EXPRESSION))
(COND
(PROGNFLG (LIST (QUOTE PROGN)
EXPRESSION T))
(T EXPRESSION])
('AND
[LAMBDA N
(PROG ((NARGS N)
EXPR1 EXPR2)
(SETQ EXPR2 (ARG N NARGS))
LP (SETQ NARGS (SUB1 NARGS))
(COND
((ZEROP NARGS)
(RETURN EXPR2)))
(SETQ EXPR1 (ARG N NARGS))
(SETQ EXPR2 ('AND2 EXPR1 EXPR2))
(GO LP])
('AND2
[LAMBDA (EXPR1 EXPR2) (* DECLARATIONS: FAST)
(PROG (TEM)
(COND
((EQ EXPR1 T)
EXPR2)
((EQ EXPR2 T)
EXPR1)
((EQUAL EXPR1 EXPR2)
EXPR2)
((EQUAL EXPR1 (UNCROP EXPR2))
EXPR2)
((EQ (CAR EXPR1)
(QUOTE PROGN))
(SETQ TEM (FLAST EXPR1))
(FRPLACA TEM ('AND (CAR TEM)
EXPR2))
EXPR1)
((AND (EQ (CAR EXPR2)
(QUOTE COND))
(NOT (CDDR EXPR2)))
(FRPLACA (CADR EXPR2)
('AND EXPR1 (CAADR EXPR2)))
EXPR2)
((AND (EQ (CAR EXPR1)
(QUOTE COND))
(NULL (CDDR EXPR1)))
(FRPLACA (SETQ TEM (FLAST (CADR EXPR1)))
('AND (CAR TEM)
EXPR2))
EXPR1)
((AND (EQ (CAR EXPR2)
(QUOTE OR))
(EQ (CADDR EXPR2)
T))
(LIST (QUOTE COND)
(LIST EXPR1 (CADR EXPR2)
T)))
[(EQ (CAR EXPR2)
(QUOTE PROGN))
(LIST (QUOTE COND)
(CONS EXPR1 (CDR EXPR2]
[(EQ (CAR EXPR2)
(QUOTE AND))
(COND
((EQ (CAR EXPR1)
(QUOTE AND))
(NCONC EXPR1 (CDR EXPR2)))
(T (FRPLACD EXPR2 (CONS EXPR1 (CDR EXPR2]
((EQ (CAR EXPR1)
(QUOTE AND))
(NCONC1 EXPR1 EXPR2))
[(AND [OR (AND (EQ (CAR EXPR1)
(QUOTE SETQ))
(SETQ TEM EXPR1))
(AND (EQ (CAR EXPR1)
(QUOTE OR))
(EQ (CAADR EXPR1)
(QUOTE SETQ))
(EQ (CADDR EXPR1)
T)
(SETQ TEM (CADR EXPR1]
(COND
((EQ EXPR2 (CADR TEM))
TEM)
((AND (EQ (CAR EXPR2)
(QUOTE AND))
(EQ (CADR TEM)
(CADR EXPR2)))
(FRPLACA (CDR EXPR2)
TEM)
EXPR2]
([AND (EQ (CAR EXPR1)
(QUOTE PROG))
(FMEMB (CAR (SETQ TEM (NLEFT EXPR1 2)))
(QUOTE ($$LP $$SOMELP $$RPTLP]
[COND
((EQ [CAR (SETQ TEM
(CAR (LAST (CAR (LAST (CADR TEM]
(QUOTE RETURN))
(RPLACA (CDR TEM)
('AND (CADR TEM)
EXPR2)))
(T (PATHELP (QUOTE AND]
EXPR1)
(T (LIST (QUOTE AND)
EXPR1 EXPR2])
('CAR
[LAMBDA (X)
(PROG (TEM)
(COND
([NULL (SETQ TEM (CADR (FASSOC (CAR X)
CRLIST]
(LIST (QUOTE CAR)
X))
(T (LIST TEM (CADR X])
('CDR
[LAMBDA (X)
(PROG (TEM)
(COND
([NULL (SETQ TEM (CADDR (FASSOC (CAR X)
CRLIST]
(LIST (QUOTE CDR)
X))
(T (LIST TEM (CADR X])
('EQ
[LAMBDA (VAR EXPRESSION)
(COND
((NULL EXPRESSION)
('NULL VAR))
((ZEROP EXPRESSION)
(LIST (QUOTE ZEROP)
VAR))
(T (LIST (QUOTE EQ)
VAR EXPRESSION])
('EQLENGTH
[LAMBDA (VAR LEN)
(* THIS SHOULD REALLY TAKE
(EQLENGTH (CDDDR X) 10) AND TRANSLATE IT TO
(EQLENGTH X 13))
(SELECTQ (CAR (LISTP VAR))
(CDR ('EQLENGTH (CADR VAR)
('PLUS LEN 1)))
(CDDR ('EQLENGTH (CADR VAR)
('PLUS LEN 2)))
(CDDDR ('EQLENGTH (CADR VAR)
('PLUS LEN 3)))
(CDDDDR ('EQLENGTH (CADR VAR)
('PLUS LEN 4)))
(COND
((ZEROP LEN)
('NULL VAR))
(T (LIST (QUOTE EQLENGTH)
VAR LEN])
('EQUAL
[LAMBDA (VAR EXPRESSION)
[COND
((AND (EQ (CAR EXPRESSION)
(QUOTE QUOTE))
(SELFQUOTEABLE (CADR EXPRESSION)))
(SETQ EXPRESSION (CADR EXPRESSION]
(COND
((NULL EXPRESSION)
('NULL VAR))
((EQ EXPRESSION T)
('EQ VAR EXPRESSION))
(T (LIST (COND
([OR (SMALLP EXPRESSION)
(AND (EQ (CAR EXPRESSION)
(QUOTE QUOTE))
(LITATOM (CADR EXPRESSION]
(QUOTE EQ))
((NUMBERP EXPRESSION)
(QUOTE EQP))
((STRINGP EXPRESSION)
(QUOTE STREQUAL))
(T (QUOTE EQUAL)))
VAR EXPRESSION])
('LAST
[LAMBDA (X)
(LIST (LOOK (QUOTE LAST)
X)
X])
('F/L
[LAMBDA (ARGS EXPR)
(DSUBST (CAR ARGS)
('CAR (CADR ARGS))
EXPR)
(LIST (QUOTE FUNCTION)
(COND
([AND (EQ (CADR EXPR)
(CAR ARGS))
(OR (AND (EQLENGTH EXPR 2)
(EQ (PATNARGS (CAR EXPR))
1))
(AND (EQ (PATNARGS (CAR EXPR))
1)
(EQLENGTH EXPR 3)
(EQ (CADDR EXPR)
(CADR ARGS]
(CAR EXPR))
(T (LIST (QUOTE LAMBDA)
ARGS EXPR])
('APPLY*
[LAMBDA (FNNAME VAR)
(COND
((OR (NLISTP FNNAME)
(EQ (CAR FNNAME)
(QUOTE LAMBDA)))
(LIST FNNAME VAR))
(T (SUBST VAR (QUOTE @)
FNNAME])
('HEADPLOOP
[LAMBDA (VAR HEADLIST TAILVAR CANNILFLG AFTEREXP)
(* (FOR {TAILVAR⎇ ON {VAR⎇ BIND {TEMVAR⎇←{HEADLIST⎇
WHILE {TAILVAR⎇:1 EQUALS {TEMVAR⎇:1 DO
(IF NIL={TEMVAR⎇←{TEMVAR⎇::1 THEN
(RETURN {AFTER⎇))))
(PROG (TEMVAR)
(SUBPAIR (QUOTE (TEMVAR AFTER VAR TAILVAR HEADLIST))
(LIST (SETQ TEMVAR (BOUNDVAR))
(COND
[(EQ AFTEREXP T)
('OR (LIST ('NULL TEMVAR)
('EQ TEMVAR TAILVAR]
((NOT CANNILFLG)
('AND ('NULL TEMVAR)
AFTEREXP))
(T ('AND ('OR (LIST ('NULL TEMVAR)
('EQ TEMVAR TAILVAR)))
AFTEREXP)))
VAR TAILVAR HEADLIST)
(QUOTE (PROG NIL
(SETQ TAILVAR VAR)
(SETQ TEMVAR HEADLIST)
$$LP(COND
((LISTP TEMVAR)
(COND
((AND (LISTP TAILVAR)
(EQUAL (CAR TAILVAR)
(CAR TEMVAR)))
(SETQ TAILVAR (CDR TAILVAR))
(SETQ TEMVAR (CDR TEMVAR))
(GO $$LP)))
(RETURN))
(T (RETURN AFTER])
('LDIFF
[LAMBDA (X Y)
(LIST (QUOTE LDIFF)
X Y])
('PROG
[LAMBDA (VARS STATEMENTS)
(COND
((AND (NULL (CDR STATEMENTS))
(EQ (CAAR STATEMENTS)
(QUOTE PROG)))
(RPLACA (CDAR STATEMENTS)
(APPEND (CADAR STATEMENTS)
VARS))
(CAR STATEMENTS))
(T (CONS (QUOTE PROG)
(CONS VARS STATEMENTS])
('NCONC
[LAMBDA (VAR1 VAR2)
(COND
((NULL VAR1)
VAR2)
(T (LOOKLIST (QUOTE NCONC)
VAR1 VAR2])
('FOR
[LAMBDA ({OLD⎇ I.V. {ON⎇VAR {UNTIL⎇EXPR {FINALLY⎇EXPR NOSOMEFLG)
(PROG (TEM1)
(AND (EQ {UNTIL⎇EXPR T)
(PATHELP " a SOME with null terminator"
(LIST {OLD⎇ I.V. {ON⎇VAR {FINALLY⎇EXPR)))
(AND NOSOMEFLG (GO DOPROG))
[SETQ TEM1 (OR (SELECTQ (CAR {UNTIL⎇EXPR)
(EQ (AND (EQUAL (CADR {UNTIL⎇EXPR)
('CAR I.V.))
(LOOKLIST (QUOTE MEMB)
(CADDR {UNTIL⎇EXPR)
{ON⎇VAR)))
(EQUAL (AND (EQUAL (CADR {UNTIL⎇EXPR)
('CAR I.V.))
(LIST (QUOTE MEMBER)
(CADDR {UNTIL⎇EXPR)
{ON⎇VAR)))
NIL)
(LIST (QUOTE SOME)
{ON⎇VAR
('F/L (LIST (GENSYML)
I.V.)
{UNTIL⎇EXPR]
(RETURN (COND
[(OR {OLD⎇ (NEQ {FINALLY⎇EXPR T))
(MAKESUBST0 I.V. TEM1)
(* OLD on means that I.V. is going to be used later
on. Thus, we set up to substitute TEM1 for I.V.
later, and return I.V. now)
(RETURN (COND
((NEQ {FINALLY⎇EXPR T)
{FINALLY⎇EXPR)
(T I.V.]
(T TEM1)))
DOPROG
(RETURN
('PROG
(AND (NOT {OLD⎇)
(LIST (LIST I.V. {ON⎇VAR)))
(NCONC
(AND {OLD⎇ (LIST ('SETQ (BINDVAR I.V.)
{ON⎇VAR)))
(LIST (QUOTE $$SOMELP)
(LIST (QUOTE COND)
(LIST ('NOT {UNTIL⎇EXPR)
[LIST (QUOTE COND)
(LIST ('LISTP I.V.)
('SETQ I.V. ('CDR I.V.))
(QUOTE (GO $$SOMELP]
(QUOTE (RETURN)))
(LIST T (LIST (QUOTE RETURN)
{FINALLY⎇EXPR])
('PROGN
[LAMBDA (EXPRLST)
(PROG (X)
(OR EXPRLST (RETURN T))
(SETQ EXPRLST (FORMEXPAND EXPRLST (QUOTE PROGN)))
(while (AND (CDR EXPRLST)
(NLISTP (CAR EXPRLST)))
do (SETQ EXPRLST (CDR EXPRLST)))
(SETQ X EXPRLST)
LP (COND
((CDDR X)
[COND
((NLISTP (CAR X))
(FRPLACA X (CADR X))
(FRPLACD X (CDDR X)))
(T (SETQ X (CDR X]
(GO LP)))
(RETURN (COND
((CDR EXPRLST)
(CONS (QUOTE PROGN)
EXPRLST))
(T (CAR EXPRLST])
('LISTP
[LAMBDA (X)
(LIST (QUOTE LISTP)
X])
)
(DEFINEQ
(PATERR
[LAMBDA (MSG AT)
(CLISPERROR
(LIST (SELECTQ MSG
(BADNOT "Cannot negate a non-element pattern")
(TWO! "Two !'s in a row")
(BAD*"invalid *")
(BAD# "invalid #")
(BADELT "Pattern item not atom or list ")
(NOWITH "no WITH")
(AMBIG "ambiguous pattern")
(!AT "!atom in middle of pattern")
(OR MSG "bad pattern"))
AT MATCHEXPRESSION)
T)
(ERROR!])
(PATHELP
[LAMBDA (MESS1 MESS2)
(LISPXPRIN1 "error in Pattern Match" T)
(LISPXTERPRI T)
(HELP MESS1 MESS2])
(LOOKLIST
[LAMBDA (FN ARG ARG')
(LIST (LOOK FN ARG ARG')
ARG ARG'])
(VALUELOOKUP
[LAMBDA (VAR)
(COND
(LOCALDECLARATION (CLISPLOOKUP0 VAR (CADR MATCHEXPRESSION)
NIL LOCALDECLARATION NIL
(QUOTE VALUE)))
(T (CAR VAR])
(LOOK
[LAMBDA (FN ARG ARG')
(PROG (CLASS CLASSDEF (LISPFN (OR (GETP FN (QUOTE LISPFN))
FN)))
(COND
([AND LOCALDECLARATION (SETQ CLASSDEF (GETP FN
(QUOTE
CLISPCLASSDEF]
(CLISPLOOKUP0 FN ARG ARG' LOCALDECLARATION LISPFN
(GETP FN (QUOTE CLISPCLASS))
CLASSDEF))
(T LISPFN])
(VARCHECK
[LAMBDA (VAR NOMESSFLG SPELLFLG PROPFLG)
(* Checks if VAR is really a variable -
Used by MAKEDEFAULT to avoid bad parsings)
(OR (AND (LITATOM VAR)
(OR (FMEMB VAR VARS)
(NEQ (EVALV VAR)
(QUOTE NOBIND)))
VAR)
(AND (NOT NOMESSFLG)
(ERROR VAR "NOT A VARIABLE" T])
(TRUE
[LAMBDA NIL T])
)
(DECLARE
(BLOCK: MATCHBLOCK MAKEMATCH 'MATCHTOP 'MATCHSUBPAT 'MATCHWM
'MATCHWMFUNARG CHECKSETQ 'MATCHELT1 'MATCHELT PATPARSE
PATPARSE1 PARSEDEFAULT PATUNPACK PATUNPACKINFIX PATGETFNNAME
PATGETEXPR PATPARSEAT MAKE!PAT MAKESUBPAT NEGATEPAT PACKLDIFF
SKIP$I SKIP$ANY PATLEN $? ELT? SIMPLELT? ARB? NULLPAT? NILPAT
CANMATCHNIL CANMATCHNILLIST REPLACEIN REPLACED
EASYTORECOMPUTE TEST# NEVERNIL FULLEXPANSION GENSYML
MAKESUBST MAKESUBST0 MAKESUBST3 MAKESUBST1 DOSUBST DOSUBST1
FORMEXPAND POSTPONEDREPLACE POSTPONEDSETQ SUBSTVAR BOUNDVAR
BINDVAR SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH UNCROP PATNARGS
UNCDR CHECKEASYVAR 'NLEFT 'NOT 'NULL 'NOT1 'NOTLESSPLENGTH
'NTH 'OR 'PLUS 'REPLACE 'SETQ 'AND 'AND2 'CAR 'CDR 'EQ
'EQLENGTH 'EQUAL 'LAST 'F/L 'APPLY* 'HEADPLOOP 'LDIFF 'PROG
'NCONC 'FOR 'PROGN 'LISTP PATERR PATHELP LOOKLIST LOOK
VALUELOOKUP VARCHECK TRUE (ENTRIES MAKEMATCH)
(GLOBALVARS PATCHARS CRLIST MAXCDDDDRS PATNONNILFUNCTIONS
PATGENSYMVARS PATTERNITEMS PATTERNPREFIXES
PATTERNREPLACEOPRS PATTERNINFIXES PATTERNCHARRAY
NEVERNILFUNCTIONS)
(LOCALFREEVARS WATCHPOSTPONELST SUBLIST INASOME
CHECKINGLENGTH WMLST LASTEFFECTCANBENIL
POSTPONEDEFFECTS MUSTRETURN BINDINGS
GENSYMVARLIST SKIPEDLEN ZLENFLG
LOCALDECLARATION MATCHEXPRESSION MATCHEFFECTS
CHECKLENGTH #LIST PATVARSNILLOOKED PATVARSNIL
POSTPONEDRPLACS LISTPCHECK DEFAULTLST
VARDEFAULT)
(SPECVARS EXPR FAULTFN VARS CLISPCHANGE)
(BLKAPPLYFNS TRUE 'MATCHWMFUNARG))
) (RPAQQ PATCHARS ((($ <)
T $<)
(($ >)
T $>)
(($ =)
T $=)
((')
T ')
((!)
T !)
((= =)
T ==)
((=)
T =)
((})
T })
((< -)
NIL <-)
((@)
NIL @)
((←)
NIL ←)
(($)
T $)))
(RPAQQ PATTERNINFIXES (((←)
T ←)
((< -)
T <-)
((@)
T @)))
(RPAQQ PATTERNREPLACEOPRS ((← ← →)
(←← <- ->)
(<- <- ->)))
[RPAQQ PATTERNITEMS ((&)
(--)
($$ --)
(T)
(NIL)
(&)
(--)
($)
($1 &)
($2 ($= . 2))
($3 ($= . 3))
($4 ($= . 4))
($5 ($= . 5))
($6 ($= . 6]
(RPAQQ PATTERNPREFIXES ((== EXPR (== . HERE))
(= EXPR (= . HERE))
(' T (' . HERE))
(! PAT MAKE!PAT)
(%. PAT MAKE!PAT)
($> EXPR ($> . HERE))
($< EXPR ($< . HERE))
($= EXPR ($= . HERE))
(} PAT NEGATEPAT)))
(RPAQQ CRLIST ((CAR CAAR CDAR CAR NIL)
(CDR CADR CDDR CDR NIL)
(CDDDDR NIL NIL CDR CDDDR)
(CADDDR NIL NIL CAR CDDDR)
(CDDDR CADDDR CDDDDR CDR CDDR)
(CDADDR NIL NIL CDR CADDR)
(CAADDR NIL NIL CAR CADDR)
(CADDR CAADDR CDADDR CAR CDDR)
(CDDR CADDR CDDDR CDR CDR)
(CDDADR NIL NIL CDR CDADR)
(CADADR NIL NIL CAR CDADR)
(CDADR CADADR CDDADR CDR CADR)
(CDAADR NIL NIL CDR CAADR)
(CAAADR NIL NIL CAR CAADR)
(CAADR CAAADR CDAADR CAR CADR)
(CADR CAADR CDADR CAR CDR)
(CDDDAR NIL NIL CDR CDDAR)
(CADDAR NIL NIL CAR CDDAR)
(CDDAR CADDAR CDDDAR CDR CDAR)
(CDADAR NIL NIL CDR CADAR)
(CAADAR NIL NIL CAR CADAR)
(CADAR CAADAR CDADAR CAR CDAR)
(CDAR CADAR CDDAR CDR CAR)
(CDDAAR NIL NIL CDR CDAAR)
(CADAAR NIL NIL CAR CDAAR)
(CDAAR CADAAR CDDAAR CDR CAAR)
(CDAAAR NIL NIL CDR CAAAR)
(CAAAAR NIL NIL CAR CAAAR)
(CAAAR CAAAAR CDAAAR CAR CAAR)
(CAAR CAAAR CDAAR CAR CAR)))
(RPAQQ NEVERNILFUNCTIONS
(CONS LIST QUOTE ABS ADD1 SUB1 CONCAT REMAINDER FREMAINDER
IREMAINDER LOGOR LOGAND LOGXOR))
(RPAQQ PATNONNILFUNCTIONS (GETD NUMBERP STRINGP ZEROP LISTP SMALLP))
[RPAQ PATTERNCHARRAY (MAKEBITTABLE (NCONC (MAPCAR PATCHARS
(QUOTE CAAR))
(MAPCAR PATTERNITEMS
(QUOTE CAR]
(RPAQQ PATGENSYMVARS
(GENSYMVARS: $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11
$$12 $$13 $$14 $$15 $$16 $$17))
(RPAQQ PATTERNVARDEFAULT ('))
(RPAQQ MAXCDDDDRS 5)
(RPAQ PATTERNCHECKLENGTH T)
(RPAQ PATTERNLISTPCHECK NIL)
(RPAQ PATVARSMIGHTBENIL T)
(DEFLIST(QUOTE(
(NTH NTH)
))(QUOTE CLISPCLASS))
(DEFLIST(QUOTE(
(NTH (ACCESS NTH NIL FNTH))
))(QUOTE CLISPCLASSDEF))
(DEFLIST(QUOTE(
(NTH NTH)
))(QUOTE LISPFN))
(ADDTOVAR DECLWORDS (QUOTE (NTH)))
STOP